home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / unixport / defsystem.lsp.orig < prev    next >
Lisp/Scheme  |  1986-06-26  |  20KB  |  528 lines
  1. ;;;;    DEFSYSTEM.LSP
  2. ;;;;
  3. ;;;;    --- System Generation Tool for Kyoto Common Lisp ---
  4.  
  5.  
  6. (in-package 'lisp)
  7. (export '(defsystem defkcl defkcn))
  8. (in-package 'compiler)
  9. (in-package 'system)
  10.  
  11. ;;; *KCL-HOME-DIRECTORY*
  12. (defvar *kcl-home-directory* #"^")        ; Change!!
  13. ;(defvar *kcl-home-directory* #"../")        ; Change!!
  14.  
  15.  
  16. (defvar *port-directory*
  17.         (make-pathname :directory (append (pathname-directory
  18.                                            *kcl-home-directory*)
  19.                                           (list #+aosvs "port"
  20.                                                 #+unix "unixport"))
  21.                        :name nil :type nil))
  22. (defvar *lsp-directory*
  23.         (make-pathname :directory (append (pathname-directory
  24.                                            *kcl-home-directory*)
  25.                                           (list "lsp"))
  26.                        :name nil :type nil))
  27. #+unix
  28. (defvar *include.h*
  29.         (make-pathname :directory (append (pathname-directory
  30.                                            *kcl-home-directory*)
  31.                                           (list "h"))
  32.                        :name "include" :type "h"))
  33. (defvar *ob-directory* 
  34.         (make-pathname :directory (append (pathname-directory
  35.                                            *kcl-home-directory*)
  36.                                           (list #+aosvs "ob" #+unix "o"))
  37.                        :name nil :type nil))
  38.  
  39.  
  40. (setq *print-case* :downcase)
  41.  
  42.  
  43. (defvar *object-files*
  44.         #+aosvs
  45.         '("main" "alloc" "gbc"
  46.           "ffalt" "short" "interrupt"
  47.           "eval" "macros" "frame" "error" "reference" "assignment"
  48.           "conditional" "catch" "lex" "prog" "block" "bds"
  49.           "multival" "mapfun" "let" "iteration" "toplevel" "cmpaux"
  50.           "array" "bind" "cfun" "character" "file" "list"
  51.           "pathname" "package" "predicate" "print" "read" "backq"
  52.           "structure" "sequence" "string" "symbol" "typespec"
  53.           "big" "number" "num_arith" "num_co" "num_comp" "num_sfun" "num_log"
  54.           "num_pred" "num_rand" "earith"
  55.           "hash" "filesystem" "time"
  56.           "fasl_loader" "fasl_pass1" "fasl_pass2" "fasl_reloc" "fasl_table"
  57.           "fasl_io" "fasload"
  58.           "bitop"
  59.           "savemem" "sys"
  60.           "process"
  61.           "format")
  62.         #+unix
  63.         '("main" "alloc" "gbc"
  64.           "bitop"
  65.           "typespec"
  66.           "eval" "macros" "lex" "bds" "frame"
  67.           "predicate"
  68.           "reference" "assignment" "bind" "let"
  69.           "conditional" "block" "iteration" "mapfun"
  70.           "prog" "multival" "catch"
  71.           "symbol" "cfun" "cmpaux" "package"
  72.           "big" "number" "num_pred" "num_comp" "num_arith" "num_sfun"
  73.           "num_co" "num_log" "num_rand" "earith"
  74.           "character" "char_table"
  75.           "sequence" "list" "hash" "array" "string" "structure"
  76.           "toplevel"
  77.           "file" "read" "backq" "print" "format" "pathname" "unixfsys"
  78.           "unixfasl"
  79.           "error"
  80.           "unixtime" "unixsys" "unixsave" "unixint"))
  81.  
  82. (defvar *lsp-object-files*
  83.         '("defmacro" "evalmacros" "top" "module"))
  84.  
  85. (defvar *all-libraries*
  86.         '("predlib" "setf"
  87.           "arraylib" "assert" "defstruct" "describe"
  88.           "iolib" "listlib" "mislib" "numlib"
  89.           "packlib" "seq" "seqlib" "trace"))
  90.  
  91.  
  92. (defun change-file-type (file type)
  93.   (make-pathname :directory (pathname-directory file)
  94.                  :name (pathname-name file)
  95.                  :type type))
  96.  
  97. (defun strip-file-type (file) (change-file-type file nil))
  98.  
  99. (defun search-tree (x tree)
  100.   (loop
  101.    (cond ((equal x tree) (return t))
  102.          ((atom tree) (return nil))
  103.          ((search-tree x (car tree)) (return t))
  104.          (t (setq tree (cdr tree))))))
  105.  
  106.  
  107. (defmacro defsystem (system-name files &rest body)
  108.   (if (atom system-name)
  109.       `(make-system ',system-name ',files ',body)
  110.       `(apply #'make-system
  111.               ',(car system-name) ',files ',body
  112.               ',(cdr system-name))))
  113.  
  114. (defun make-system (system-name files initial-forms
  115.                     &key (libraries nil)
  116.                          (system system-name)
  117.                          (raw-system
  118.                           (merge-pathnames
  119.                            (format nil "raw_~A" system-name)
  120.                            system))
  121.                          (top-level nil)
  122.                          (command-file
  123.                           (format nil
  124.                                   #+aosvs "make_~A.cli" #+unix "make_~A"
  125.                                   system-name))
  126.                          (sys-file
  127.                           (format nil "sys_~A.c" system-name))
  128.                          (init-file
  129.                           (format nil "init_~A.lsp" system-name))
  130.                          #+aosvs (use-console t))
  131.  
  132.   #+aosvs (setq system (change-file-type system "pr"))
  133.   #+aosvs (setq raw-system (change-file-type raw-system "pr"))
  134.  
  135.   (cond ((eq libraries t) (setq libraries *all-libraries*)) 
  136.         (t
  137.          (dolist (library libraries)
  138.            (unless (member (string library) *all-libraries*
  139.                            :test #'string-equal)
  140.                    (error "~S is not a library." library)))
  141.          ;; Reorder the libraries.
  142.          (setq libraries
  143.                (mapcan #'(lambda (library)
  144.                            (if (member library libraries
  145.                                        :test #'string-equal :key #'string)
  146.                                (list library)
  147.                                nil))
  148.                        *all-libraries*))))
  149.  
  150.   (setq files
  151.         (mapcar #'(lambda (file)
  152.                     (if (symbolp file)
  153.                               (string-downcase (symbol-name file))
  154.                               file))
  155.                 files))
  156.  
  157.   (when (symbolp system)
  158.         (setq system (string-downcase (symbol-name system))))
  159.   (when (symbolp raw-system)
  160.         (setq raw-system (string-downcase (symbol-name raw-system))))
  161.  
  162.   (unless (search-tree 'si:init-system initial-forms)
  163.           (setq initial-forms
  164.                 (append initial-forms (list '(si:init-system)))))
  165.  
  166.   (when top-level
  167.         (setq initial-forms
  168.               (append initial-forms
  169.                       (list `(defun si:top-level () (,top-level))))))
  170.  
  171.   ;; Make the sys file.
  172.   (setq sys-file (change-file-type sys-file "c"))
  173.   (with-open-file (stream sys-file :direction :output)
  174.     #+unix
  175.     (format stream "#include \"~A\"~%~%" (namestring *include.h*))
  176.     #+aosvs
  177.     (format stream "#include \"include.h\"~%~%")
  178.     (format stream "static object fasl_data;~%~%")
  179.     (format stream "init_init()~%{~%")
  180.     (format stream "    enter_mark_origin(&fasl_data);~%")
  181.     (format stream "    fasl_data = Cnil;~%~%")
  182.     (format stream "    load(\"~A\");~%"
  183.             (namestring (merge-pathnames "export.lsp" *lsp-directory*)))
  184.     (dolist (library *lsp-object-files*)
  185.       (format stream
  186.               "    fasl_data = read_fasl_data(\"~A\");~%"
  187.               (namestring
  188.                (merge-pathnames (change-file-type library
  189.                                                   #+aosvs "fasl" #+unix "o")
  190.                                 *lsp-directory*)))
  191.       (format stream "    init_~A(NULL, 0, fasl_data);~%" library))
  192.     (format stream "    load(\"~A\");~%"
  193.             (namestring (merge-pathnames "autoload.lsp" *lsp-directory*)))
  194.     (format stream "}~%~%")
  195.     (format stream "init_system()~%{~%")
  196.     (dolist (library libraries)
  197.       (format stream
  198.               "    printf(\"Initializing ~A...  \");  fflush(stdout);~%"
  199.               library)
  200.       (format stream
  201.               "    fasl_data = read_fasl_data(\"~A\");~%"
  202.               (namestring
  203.                (merge-pathnames (change-file-type library
  204.                                                   #+aosvs "fasl" #+unix "o")
  205.                                 *lsp-directory*)))
  206.       (format stream "    init_~A(NULL, 0, fasl_data);~%" library)
  207.       (format stream
  208.               "    printf(\"\\n\");  fflush(stdout);~%"))
  209.     (format stream "~%")
  210.     (dolist (file files)
  211.       (format stream
  212.               "    printf(\"Initializing ~A...  \");  fflush(stdout);~%"
  213.               (pathname-name file))
  214.       (format stream
  215.               "    Vpackage->s.s_dbind = user_package;~%")
  216.       (format stream
  217.               "    fasl_data = read_fasl_data(\"~A\");~%"
  218.               (namestring
  219.                (change-file-type file #+aosvs "fasl" #+unix "o")))
  220.       (format stream "    init_~A(NULL, 0, fasl_data);~%"
  221.               (string-downcase (pathname-name file)))
  222.       (format stream
  223.               "    printf(\"\\n\");  fflush(stdout);~%"))
  224.     (format stream
  225.             "~%    Vpackage->s.s_dbind = user_package;~%")
  226.     (format stream "}~%"))
  227.  
  228.   ;; Make the init file.
  229.   (with-open-file (stream init-file :direction :output)
  230.     (mapcar #'(lambda (package)
  231.                 (unless (eq package (find-package 'keyword))
  232.                         (prin1 `(IN-PACKAGE ,(package-name package)) stream)
  233.                         (terpri stream)))
  234.             (list-all-packages))
  235.     (prin1 `(IN-PACKAGE ,(package-name *package*)) stream)
  236.     (terpri stream)
  237.     (prin1 (if #+aosvs use-console #+unix t
  238.                #+aosvs
  239.                `(PROGN
  240.                  ,@initial-forms
  241.                  (FORMAT T "~&~%Type in (SAVE \"~A\") and (BYE).~%~%"
  242.                          ,(namestring (strip-file-type system))))
  243.                `(PROGN
  244.                  ,@initial-forms
  245.                  (SAVE ,(namestring (strip-file-type system)))
  246.                  (BYE)))
  247.            stream)
  248.     (terpri stream))
  249.  
  250.   ;; Make the command file.
  251.   (with-open-file (stream command-file :direction :output)
  252.  
  253.     #+aosvs
  254.     ;; Set the search list.
  255.     (format stream
  256.             "push;prompt pop~%~%~
  257.              searchlist :USR:DGC :UTIL ~A~%~%"
  258.             (namestring (make-pathname
  259.                          :directory
  260.                          (pathname-directory *kcl-home-directory*)
  261.                          :name "h")))
  262.  
  263.     #+aosvs
  264.     ;; Change the current directory.
  265.     (format stream "directory ~A~%~%" (namestring (truename "=")))
  266.  
  267.     ;; Compile the sys file.
  268.     (format stream
  269.             #+aosvs
  270.             "write Compiling ~A~%~
  271.              cc/opt=2/nomap/noinclude/noextl &~%~
  272.              AOSVS/define MAXPAGE/define=2048 VSSIZE/define=2048 &~%~
  273.              ~A~%~%"
  274.             #+unix
  275.             "#~%~%~
  276.              if ({ vax }) then~%~
  277.              set MACHINE = VAX~%~
  278.              endif~%~%~
  279.              if ({ sun }) then~%~
  280.              set MACHINE = SUN~%~
  281.              endif~%~%~
  282.              echo Compiling ~A~%~
  283.              cc -c -D$MACHINE -DMAXPAGE=2048 -DVSSIZE=2048 ~A~%~%"
  284.             (namestring sys-file)
  285.             #+aosvs (namestring (strip-file-type sys-file))
  286.             #+unix (namestring sys-file))
  287.  
  288.     ;; Link the raw system.
  289.     #+aosvs
  290.     (format stream
  291.             #+aosvs
  292.             "write Linking~%~
  293.              ccl/storage=131072/task=2/mtop=34/nounx/o=~A &~%~
  294.              ~{~A ~}&~%~
  295.              ~A &~%~
  296.              ~{~A ~}&~%~
  297.              ~{~A ~}~%~%"
  298.             (namestring (strip-file-type raw-system))
  299.             (mapcar #'(lambda (object-file)
  300.                         (namestring
  301.                          (strip-file-type
  302.                           (merge-pathnames object-file *ob-directory*))))
  303.                     *object-files*)
  304.             (namestring (strip-file-type sys-file))
  305.             (mapcar #'(lambda (library)
  306.                         (namestring
  307.                          (merge-pathnames library *lsp-directory*)))
  308.                     (append *lsp-object-files* libraries))
  309.             (mapcar #'(lambda (file) (namestring (strip-file-type file)))
  310.                     files))
  311.     #+unix
  312.     (format stream
  313.             "echo Linking~%~
  314.              cc -o ~A \\~%~
  315.              ~{~A ~}\\~%~
  316.              ~A \\~%~
  317.              ~{~A ~}\\~%~
  318.              ~{~A ~}\\~%~
  319.              -lm ~%~%"
  320.             (namestring raw-system)
  321.             (mapcar #'(lambda (object-file)
  322.                         (namestring
  323.                          (change-file-type
  324.                           (merge-pathnames object-file *ob-directory*)
  325.                           "o")))
  326.                     *object-files*)
  327.             (namestring (change-file-type sys-file "o"))
  328.             (mapcar #'(lambda (library)
  329.                         (namestring
  330.                          (change-file-type
  331.                           (merge-pathnames library *lsp-directory*)
  332.                           "o")))
  333.                     (append *lsp-object-files* libraries))
  334.             (mapcar #'(lambda (file)
  335.                         (namestring (change-file-type file "o")))
  336.                     files))
  337.  
  338.     ;; Save the system.
  339.     #+aosvs
  340.     (if (not use-console)
  341.         (format stream
  342.                 "process/default/block/ioc/priority=3/input=~A &~%~
  343.                 ~A ~A~%~%"
  344.                 (namestring init-file)
  345.                 (namestring (strip-file-type raw-system))
  346.                 (namestring *port-directory*))
  347.         (format stream "write Invoke ~A and load ~A."
  348.                 (namestring (strip-file-type raw-system))
  349.                 (namestring init-file)))
  350.     #+unix
  351.     (format stream
  352.             "~A ~A < ~A~%~%"
  353.             (namestring raw-system)
  354.             (namestring *port-directory*)
  355.             (namestring init-file)))
  356.  
  357.   (format t "Command file is ~A.~%" (namestring command-file))
  358.   )
  359.  
  360.  
  361. (defvar *cmpnew-directory*
  362.         (make-pathname :directory (append (pathname-directory
  363.                                            *kcl-home-directory*)
  364.                                           (list "cmpnew"))
  365.                        :name nil :type nil))
  366.  
  367.  
  368. (defvar *lisp-implementation-version*
  369.         (multiple-value-bind (sec min hour date month year)
  370.             (get-decoded-time)
  371.           (format nil "~A ~D, ~D"
  372.                   (case month
  373.                     (1 "January") (2 "Feburary") (3 "March")
  374.                     (4 "April") (5 "May") (6 "June")
  375.                     (7 "July") (8 "August") (9 "September")
  376.                     (10 "October") (11 "November") (12 "December"))
  377.                   date year)))
  378.  
  379.  
  380. (defmacro defkcl (&key (system-name "kcl")
  381.                        #+aosvs
  382.                        (system system-name)
  383.                        #+unix
  384.                        (system (format nil "saved_~a" (string system-name)))
  385.                        (raw-system (format nil "raw_~a" (string system-name)))
  386.                        (include-compiler t)
  387.                        (libraries t)
  388.                   &aux (*package* *package*)
  389.                        )
  390.  
  391.   (in-package 'system)
  392.   (setq *check-time* nil)
  393.  
  394.   `(defsystem (,system-name
  395.                :top-level kcl-top-level
  396.                :libraries ,libraries
  397.                :system ,system
  398.                :raw-system ,raw-system
  399.                #+aosvs :use-console #+aosvs t)
  400.  
  401.              ,(if include-compiler
  402.                   (list (merge-pathnames "cmpinline" *cmpnew-directory*)
  403.                         (merge-pathnames "cmputil" *cmpnew-directory*)
  404.                         (merge-pathnames "cmptype" *cmpnew-directory*)
  405.                         (merge-pathnames "cmpbind" *cmpnew-directory*)
  406.                         (merge-pathnames "cmpblock" *cmpnew-directory*)
  407.                         (merge-pathnames "cmpcall" *cmpnew-directory*)
  408.                         (merge-pathnames "cmpcatch" *cmpnew-directory*)
  409.                         (merge-pathnames "cmpenv" *cmpnew-directory*)
  410.                         (merge-pathnames "cmpeval" *cmpnew-directory*)
  411.                         (merge-pathnames "cmpflet" *cmpnew-directory*)
  412.                         (merge-pathnames "cmpfun" *cmpnew-directory*)
  413.                         (merge-pathnames "cmpif" *cmpnew-directory*)
  414.                         (merge-pathnames "cmplabel" *cmpnew-directory*)
  415.                         (merge-pathnames "cmplam" *cmpnew-directory*)
  416.                         (merge-pathnames "cmplet" *cmpnew-directory*)
  417.                         (merge-pathnames "cmploc" *cmpnew-directory*)
  418.                         ;(merge-pathnames "cmpmain" *cmpnew-directory*)
  419.                         (merge-pathnames "cmpmap" *cmpnew-directory*)
  420.                         (merge-pathnames "cmpmulti" *cmpnew-directory*)
  421.                         (merge-pathnames "cmpspecial" *cmpnew-directory*)
  422.                         (merge-pathnames "cmptag" *cmpnew-directory*)
  423.                         (merge-pathnames "cmptop" *cmpnew-directory*)
  424.                         (merge-pathnames "cmpvar" *cmpnew-directory*)
  425.                         (merge-pathnames "cmpvs" *cmpnew-directory*)
  426.                         (merge-pathnames "cmpwt" *cmpnew-directory*))
  427.                   nil)
  428.  
  429.     (allocate 'cons 90)
  430.  
  431.     (si:init-system)
  432.  
  433.     (gbc t)
  434.  
  435.     ,@(if include-compiler
  436.           `((load ,(merge-pathnames "cmpmain.lsp" *cmpnew-directory*))
  437.             (gbc t)
  438.             (load ,(merge-pathnames "lfun_list.lsp" *cmpnew-directory*))
  439.             (gbc t)
  440.             (load ,(merge-pathnames "cmpopt.lsp" *cmpnew-directory*))
  441.             (gbc t)
  442.             (defun compile-file (&rest args
  443.                                  &aux (*print-pretty* nil)
  444.                                       (*package* *package*))
  445.               (compiler::init-env)
  446.               (apply 'compiler::compile-file1 args))
  447.             (defun compile (&rest args &aux (*print-pretty* nil))
  448.               (apply 'compiler::compile1 args))
  449.             (defun disassemble (&rest args &aux (*print-pretty* nil))
  450.               (apply 'compiler::disassemble1 args)))
  451.           nil)
  452.  
  453.     (setq *old-top-level* (symbol-function 'si:top-level))
  454.  
  455.     (defun kcl-top-level ()
  456.  
  457.       (when (> (si:argc) 1) (setq *system-directory* (si:argv 1)))
  458.  
  459.       ,@(if include-compiler
  460.             '((when (>= (si:argc) 5)
  461.                 (let ((si::*quit-tag* (cons nil nil))
  462.                       (si::*quit-tags* nil)
  463.                       (si::*break-level* 0)
  464.                       (si::*break-env* nil)
  465.                       (si::*ihs-base* 1)
  466.                       (si::*ihs-top* 1)
  467.                       (si::*current-ihs* 1)
  468.                       (*break-enable* nil))
  469.                   (si:error-set 
  470.                    '(let ((flags (si:argv 4)))
  471.                       (setq si:*system-directory* (pathname (si:argv 1)))
  472.                       (compile-file
  473.                        (si:argv 2)
  474.                        :output-file (si:argv 3)
  475.                        #+unix :o-file
  476.                        #+aosvs :fasl-file
  477.                        (case (schar flags 1)
  478.                          (#\0 nil) (#\1 t) (t (si:argv 5)))
  479.                        :c-file
  480.                        (case (schar flags 2)
  481.                          (#\0 nil) (#\1 t) (t (si:argv 6)))
  482.                        :h-file
  483.                        (case (schar flags 3)
  484.                          (#\0 nil) (#\1 t) (t (si:argv 7)))
  485.                        :data-file
  486.                        (case (schar flags 4)
  487.                          (#\0 nil) (#\1 t) (t (si:argv 8)))
  488.                        #+aosvs :ob-file
  489.                        #+aosvs
  490.                        (case (schar flags 5)
  491.                          (#\0 nil) (#\1 t) (t (si:argv 9)))
  492.                        :system-p 
  493.                        (if (char-equal (schar flags 0) #\S) t nil))))
  494.                   (bye))))
  495.             nil)
  496.  
  497.       (format t "KCl (Kyoto Common Lisp)  ~A~%"
  498.               ,*lisp-implementation-version*)
  499.  
  500.       (in-package 'user)
  501.  
  502.       (funcall *old-top-level*))
  503.  
  504.     (defun lisp-implementation-version () ,*lisp-implementation-version*)
  505.  
  506.     (setq *modules* nil)
  507.  
  508.     (gbc t)
  509.  
  510.     (si:reset-gbc-count)
  511.  
  512.     (allocate 'cons 200)
  513.  
  514.     #+unix (defun si:top-level () (kcl-top-level))
  515.  
  516.     #+unix (si:save-system ,system)
  517.     #+unix (bye)
  518.  
  519.     #+aosvs (format t "~%Use SI:SAVE-SYSTEM instead of SAVE.~%")
  520.  
  521.     )
  522. )
  523.  
  524. (defmacro defkcn (&rest r)
  525.   `(defkcl :include-compiler nil
  526.            :system-name kcn
  527.            ,@r))
  528.